Software Vault: The Diamond Collection/The Diamond Collection (Software Vault)(Digital Impact).ISO/cdr27/qtxt100.zip/QTXT.PAS

Pascal/Delphi Source File | 1995-02-24 | 15KB | 467 lines

PROGRAM QTXT; {v1.00 - Free DOS utility: Converts .QWK packets to text files.}
{$M 5120,0,102400}  { 100k reserved for data }
{$N-,E- no math support needed}
{$X- function calls may not be discarded}
{$I-} {disable I/O checking - trap errors by checking IOResult}

{===========================================================================}
                       (** Global declarations ... **)
{===========================================================================}

USES    DOS, CRT;

CONST   cursorState : byte = 1;  {0..3}
        cursorData : array [0..3] of char = (#179, #47, #196, #92);
        MaxConfs = 5337;
        ConfNameLength = 12;

TYPE    ConfNameArray=Array[0..MaxConfs] of Array[1..ConfNameLength] of char;

VAR     UnArcQWK : pathstr;
        BBSid    : string[12];
        CNames   : ConfNameArray;

{===========================================================================}
                   (** Custom help & exit procedure ... **)
{===========================================================================}

var SavedExitProc: Pointer;
procedure cursorOn; forward;

procedure CustomExit; far;
{---- Always exit through here ----}
const
  progdesc = 'QTXT v1.00 - Free DOS utility: Converts .QWK packets to text files.';
  author   = 'February 24, 1995. Copyright (c) 1995 by David Daniel Anderson - Reign Ware.';
  usage    = 'Usage:    QTXT <QWKpacket(s)>';
  example  = 'Example:  QTXT c:\qwks\*.qwk';
  note     = 'Note: DOS wildcards may be used when specifying the QWKpackets.';

var
  message: string[79];
begin
  ExitProc := SavedExitProc;
  cursorOn;
  if (ExitCode > 0) then begin
    writeln(progdesc);
    writeln(author);    writeln;
    writeln(usage);
    writeln(example);   writeln;
    writeln(note);      writeln;
  end;
  if ErrorAddr <> nil then
  begin
    writeln('An unanticipated error occurred, please contact DDA with the following data:');
    writeln('Address = ', Seg(ErrorAddr^), ':', Ofs(ErrorAddr^));
    writeln('Code    = ', Exitcode);
    ErrorAddr := nil;
  end
  else
    if (ExitCode > 0) and (ExitCode < 255) then begin
       case ExitCode of
         2 : message := 'No files found.  First parameter must be a valid file specification.';
         5 : message := 'Not enough memory to extract MESSAGES.DAT - aborting!';
         6 : message := 'You cannot just specify a path, add "*.*" or "\*.*" for all files.';
         7 : message := 'File handling error.  Text file is most likely incomplete - or nonexistent.';
       else  message := 'Unknown error.';
       end;
       writeln (#7, 'Error encountered, number ',ExitCode,':'); writeln (message);
    end;
end;

{===========================================================================}
                      (** Supporting subroutines ... **)
{===========================================================================}

procedure iocheck(const iores :byte);
begin
  if iores <> 0 then halt(7);
end;

procedure cursorOn;assembler;asm
  mov ah,3; mov bh,0; int $10; and ch,not $20; mov ah,1; int $10;
end;

procedure cursorOff;assembler;asm
  mov ah,3; mov bh,0; int $10; or ch,$20; mov ah,1; int $10;
end;

procedure updateCursor;
begin
  cursorState := succ(cursorState) and 3;
  write(cursorData[cursorState], ^H);
end;

FUNCTION leadingzero (CONST w: word): STRING;
VAR
  s : STRING;
BEGIN
  str (w :0, s);
  IF (length (s) = 1) THEN
    s:='0'+s;
  leadingzero:=s;
END;

Function RPad(bstr: string; Const len: byte): string;
Begin
  while (length(bstr) < len) do
    bstr := bstr + #32;
  RPad := bstr;
End;

FUNCTION RTrim(InStr: STRING): STRING;
BEGIN
  WHILE (LENGTH(InStr) > 0) AND (InStr[LENGTH(InStr)] in [#0,#9,#32]) DO
    DEC(InStr[0]);
  RTrim := InStr;
END;

function Squeeze(ss:string): string;
var
  controlCHAR: char;
begin
  for controlCHAR:=#0 to #31 do
  while (ord(ss[0]) > 0) and (Pos(controlCHAR,ss) > 0) do
    ss[Pos(controlCHAR,ss)]:=#32;
  while (ord(ss[0]) > 0) and (ss[1]=#32) do
    delete(ss,1,1);
  ss := RTrim(ss);
  Squeeze:=ss
end;

function fileexists(const filename: pathstr): boolean;
var
  attr : word;
  f    : file;
begin
  assign (f, filename);
  getfattr (f, attr);
  if (DOSerror <> 0) OR ((attr and directory) = directory) then
    fileexists := FALSE
  else
    fileexists := TRUE;
end;

procedure EraseFile(const MSGFile : string);
var
  df : file;
begin
  if fileexists(MSGFile) then begin
    assign(df, MSGFile);
    erase(df); iocheck(ioresult);
  end;
end;

{===========================================================================}
                       (** Primary subroutines ... **)
{===========================================================================}

procedure InitArcQWK;
var
  epath, cpath  : pathstr;
    {epath & cpath are fully qualified pathnames of .exe & .cfg files}
  edir: dirstr; ename: namestr; eext: extstr;
  config        : text;
  configline    : string[80];
begin
  epath := (paramstr (0));
  fsplit(fexpand(epath),edir,ename,eext); { break up path into components }
  cpath := edir+ename+'.cfg';

  UnArcQWK:='pkunzip -# -o';
  if fileexists(cpath) then
  begin
    assign (config, cpath);
    reset (config); iocheck(ioresult);
    repeat  { find vars }
      readln(config,configline);
      if (length(configline) > 10) and
        (copy(configline,1,9) = 'UNARCQWK=') then
        UnArcQWK := Copy(configline,10,length(configline)-9);
    until eof(config); { loop back to read another line }
    close (config);
  end;
end;
{===========================================================================}

function GetQWKdir(const pstr: string; var QP: pathstr): dirstr;
var
  QWKpath   : pathstr;    { QWK file path,          }
  QWKdir    : dirstr;     {             directory,  }
  QWKname   : namestr;    {             name,       }
  QWKext    : extstr;     {             extension.  }
BEGIN
  QWKpath:=pstr;
  if QWKpath[1] in ['/','-'] then halt(255);
  fsplit(fexpand(QWKpath),QWKdir,QWKname,QWKext);
    if (QWKname = '')  then halt(6);
  QP:=QWKpath;
  GetQWKdir:=QWKdir;
END;

function ExtractDAT(const QWKfile, DATfileName : string): boolean;
var
  x,y : byte;
begin
  x:=WhereX;
  y:=WhereY;
  swapvectors;
     exec (getenv ('COMSPEC'),' /c '+UnArcQWK+' '+QWKfile+' '+DATfileName);
     if doserror <> 0 then halt(5);
  swapvectors;
  GotoXY(x,y);
  ClrEOL;
  cursorOff;
  ExtractDAT:=fileexists(DATfileName)
end;
{===========================================================================}

Function InitConfNamesArray(Const QWKpath, CNFFileName: string): string;
var x,y: word;
  CNFFile  : text;
  CNameStr : string;
  CNumb,
  CNameInt : word;
  BBSname  : string[12];
  VErr     : integer;
BEGIN
  BBSname := 'unknown'+#32#32#32#32#32#32#32;
  for x := 0 to (MaxConfs - 1) do
    FillChar(CNames[x],12,#32);

  if ExtractDAT(QWKpath, CNFFileName) then begin
    Assign (CNFFile, CNFFileName);
    Reset (CNFFile); iocheck(ioresult);

    for x := 1 to 5 do                    { advance to BBSid }
      if not EOF(CNFFile) then
        Readln(CNFFile,CNameStr);

    if not EOF(CNFFile) and (Pos(',',CNameStr) > 0) then begin
      Delete(CNameStr,1,Pos(',',CNameStr));
      BBSname:=RPad(Squeeze(CNameStr),12);         { extract BBSname }
    end;

    for x := 1 to 5 do      { advance to just before number of conferences }
      if not EOF(CNFFile) then
        Readln(CNFFile,CNameStr);

    if not EOF(CNFFile) then begin
      Readln(CNFFile,CNameStr);           { get number of conferences }
      Val(Squeeze(CNameStr),CNameInt,VErr);
      if (VErr=0) then
      for x := 0 to CNameInt do           { walk through conf names }
        if not EOF(CNFFile) then begin
          Readln(CNFFile,CNameStr);       { read conference number }
          Val(Squeeze(CNameStr),CNumb,VErr);
          if (VErr=0) and (not EOF(CNFFile)) then begin
            Readln(CNFFile,CNameStr);     { read conference name }
            for y := 1 to length(CNameStr) do
              if (y <= ConfNameLength) then
                CNames[CNumb][y] := CNameStr[y];
          end;
        end;
    end;
    Close(CNFFile);
    EraseFile(CNFFileName);
  end;
  InitConfNamesArray:=BBSname;
END;
{===========================================================================}

function AdjustTime(time: string): string;
var ampm : char;
    hour : byte;
    VErr : integer;
begin
 ampm := 'a';
 Val(Copy(time,1,2), hour, VErr);

 if (hour >= 12) then begin
   ampm := 'p';
   if (hour >= 13) then
     hour := hour - 12;
 end;
 AdjustTime := LeadingZero(hour)+Copy(time,3,3)+ampm;
end;

PROCEDURE ProcessHeader (var MSGFile: file; var TXTfile: text; var NumChunks:integer);
CONST
  herald    = '===============================================================================';
  Separator = '-------------------------------------------------------------------------------';
  space=#32;

(* Note: the meaning of the status flag in the header of the QWK format
         specification is interpreted differently by different products.

   According to Patrick Y. Lee's "QWK Mail Packet File Layout" v1.0
   and Robomail v1.30, an asterisk ('*') means private and received,
                 and the plus sign ('+') means private and NOT received.

   SLMR 2.1a, SPEED and OLX v1.53 seem to agree that the meaning of the
   two symbols is reversed.

   Since this is a SPEED utility, I've used the latter.  Thus, the private
   and received flags will be translated into the following symbols:

              public, unread   =  ' '  (#32)
              public, read     =  '-'  (#45)
              private, unread  =  '*'  (#42)
              private, read    =  '+'  (#43)
*)
TYPE
  MSGDATHdr=RECORD
    Status   :Char;
    MSGNum   :ARRAY [1..7] OF Char;
    Date     :ARRAY [1..8] OF Char;
    Time     :ARRAY [1..5] OF Char;
    WhoTo    :ARRAY [1..25] OF Char;
    WhoFrom  :ARRAY [1..25] OF Char;
    Subject  :ARRAY [1..25] OF Char;
    PassWord :ARRAY [1..12] OF Char;
    ReferNum :ARRAY [1..8] OF Char;
    NumChunk :ARRAY [1..6] OF Char;
    Alive    :Byte;
    ConfNumb :Word;
    Reserved :ARRAY [1..3] OF Char;
  END;
VAR
  VErr : integer;
  MessageHeader : MSGDATHdr;
BEGIN
  updateCursor;
  BlockRead (MSGFile, MessageHeader, 1);
  Val(Squeeze(MessageHeader.NumChunk), NumChunks, VErr);
  if (VErr<>0) then NumChunks:=0;
  IF NumChunks <> 0 THEN
    WITH MessageHeader DO BEGIN
      Writeln (TXTfile, herald);
      Writeln (TXTfile, space:5,'Date: ', Date,
                        space:4,'Time: ',AdjustTime(Time),
                        space:5,'Number: ', MSGNum);
      Writeln (TXTfile, space:5,'From: ', WhoFrom,
                        space:5,'Refer: ', ReferNum);
      Write   (TXTfile, space:7,'To: ', WhoTo,
                        space:2,'Board ID: ',BBSid,
                        space:4,'Recvd: ');
                     IF Status IN [#32,#42,#126,#37,#33,#36] {unread symbols}
                        THEN Writeln (TXTfile, 'No')
                        ELSE Writeln (TXTfile, 'Yes');
      Write   (TXTfile, space:2,'Subject: ', Subject,
                        space:4, ConfNumb:6, ': ',CNames[ConfNumb],
                        space:3,'Status: ');
                     IF Status IN [#43,#42,#126,#96,#33,#35] {private symbols}
                        THEN Writeln (TXTfile, 'Private')
                        ELSE Writeln (TXTfile, 'Public');
      Writeln (TXTfile, Separator);
    END;
END;
{===========================================================================}

PROCEDURE ProcessMessage (var MSGFile: file; var TXTfile: text; NumChunks:Integer);
var
  Buff     : ARRAY [1..128] OF Char;
  BuffStr  : string;
  QRecs    : Integer;
  BuffByte : Byte;
BEGIN
  BuffStr := '';
  FOR QRecs := 1 TO Pred (NumChunks) DO BEGIN
    BlockRead (MSGFile, Buff, 1);
    FOR BuffByte := 1 TO 128 DO
      IF Buff [BuffByte] = #227
        THEN BEGIN
          Writeln (TXTfile,RTrim(BuffStr));
          BuffStr := '';
        END
        ELSE BuffStr := BuffStr + Buff[BuffByte];
  END;
  Writeln (TXTfile,RTrim(BuffStr))
END;
{===========================================================================}

PROCEDURE ProcessFiles (var MSGFile: file; var TXTfile: text);
var
  QWKrecs,
  Chunks    :Integer;
BEGIN
    QWKrecs := 2;                         { start at RECORD #2 }
    WHILE QWKrecs < FileSize (MSGFile) DO BEGIN
      Seek (MSGFile, QWKrecs - 1);
      ProcessHeader (MSGFile,TXTfile,Chunks);
      IF Chunks <> 0
        THEN ProcessMessage (MSGFile,TXTfile,Chunks)
        ELSE Chunks := 1;
      Inc (QWKrecs, Chunks);
    END;
END;

{===========================================================================}
                           (** Main program ... **)
{===========================================================================}

CONST
  MSGFileName = 'MESSAGES.DAT';
  CNFFileName = 'CONTROL.DAT';

var
  MSGFile : File;
  TXTfile : Text;

  QWKpath    : pathstr;    { QWK file path. }
  QWKdir     : dirstr;     { QWK file dir.  }
  TXTpath    : pathstr;    { TXT file path. }
  fileinfo   : SearchRec;

BEGIN
  SavedExitProc := ExitProc;
  ExitProc := @CustomExit;
  CheckBreak:=true;
  cursorOff;

  if ParamCount <> 1 then halt(255);
  InitArcQWK;
  QWKdir:=GetQWKdir(ParamStr(1), QWKpath);

  findfirst(QWKpath, archive, fileinfo); if doserror <> 0 then halt(2);
  Writeln ('QTXT v1.00 - Free QWK to TXT convertor is now working.');
  while doserror = 0 do
  begin
    QWKpath := QWKdir + fileinfo.name;
    TXTpath := fileinfo.name;
      if (Pos('.',TXTpath) > 0) and (Pos('.',TXTpath) < length(TXTpath)) then
        TXTpath[1+Pos('.',TXTpath)] := 'T'
      else
        TXTpath := TXTpath+'.T';

    Write ('Checking ', QWKpath, ' and ', TXTpath);
    IF fileexists (TXTpath)
      THEN Writeln (' ... text file exists - skipping.')
      ELSE begin
        Writeln(', done!');
        EraseFile(MSGFileName);
        Write('Extracting MESSAGES.DAT from ',QWKpath,' ...');
        if ExtractDAT(QWKpath, MSGFileName) then begin

          Writeln(' done!');
          BBSid:=InitConfNamesArray(QWKpath, CNFFileName);
          Assign (MSGFile, MSGFileName);
          Reset (MSGFile, 128); iocheck(ioresult);
          Assign (TXTfile, TXTpath);
          Rewrite (TXTfile); iocheck(ioresult);
          Write('Translating messages to ',TXTpath,#32);
          ProcessFiles (MSGFile, TXTfile);
          Writeln(#8,', done!');
          Close (MSGFile); iocheck(ioresult);
          Close (TXTfile); iocheck(ioresult);

          EraseFile(MSGFileName);
        end
        else
          writeln('- bad QWK - skipping.');
      END;
    findnext(fileinfo);
  end;
  writeln('Mission accomplished!');
END.